Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/t3_1/risc_src.lha/risc_sources/comp/back_end/bookkeep.t

Text File | 1989-10-27 | 16.3 KB | 506 lines

(herald (back_end bookkeep)
  (env t (orbit_top defs)))

;;; Copyright (c) 1985 Yale University
;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department.  Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;;    to the T Project at Yale any improvements or extensions that they make,
;;;    so that these may be included in future releases; and (b) to inform
;;;    the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;;    shall duly acknowledge such use, in accordance with the usual standards
;;;    of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;;    this software will be error-free, and Yale is under no obligation to
;;;    provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;;    there shall be no use of the name of the Yale University nor of any
;;;    adaptation thereof in any advertising, promotional, or sales literature
;;;    without prior written consent from Yale in each case.
;;;

;;; Copyright (c) 1985 David Kranz

(define (do-reg-positions node args p-list proc?)
  (if p-list
      (return args p-list)
      (let ((len (length args))
        (m (if proc? (fx+ *argument-registers* 1) *argument-registers*)))
    (cond ((fx<= len m)
           (return args (reg-positions len proc?)))
          (else
           (generate-extra-args-cons (fx- len m))
           (do ((a (nthcdr args m) (cdr a))
            (i 0 (fx+ i 1)))
           ((null? a) (return (sublist args 0 m)
                      (reg-positions m proc?)))
         (generate-extra-arg-store node (car a) i)))))))

(define (reg-positions i proc?)
  (let ((end (if proc? i (fx+ i 1))))
    (do ((i (if proc? p (fx+ p 1)) (fx+ i 1))
     (l '() (cons (if (fx<= i *argument-registers*)
              i
              (bug "Too many arguments"))
              l)))
    ((fx>= i end)
     (reverse! l)))))

(define-constant lambda-max-temps node-instructions)
(define-constant lambda-known-state node-instructions)

;;; Registers and temps are represented in the same structure

(define-integrable reg-node
  (object (lambda (reg)
            (vref *registers* reg))
          ((setter self)
           (lambda (reg node)
             (vset *registers* reg node)))))

(define-integrable temp-node reg-node)

;;; ->REGISTER Move the value of leaf-node REF into a register of type TYPE
;;; which can be either '* or a specific register. Force an existing value out
;;; if necessary,

(define (access-value node var)
  (->addressable node var))

(define (->addressable node var)
  (let ((acc (lookup-value node var)))
    (cond ((allowed-mode? acc)
       acc)
      (else
       (into-register node var acc)))))


(define (->register node var)
  (let ((accessor (lookup-value node var)))
    (cond ((register? accessor)
           accessor)
          (else
           (into-register node var accessor)))))

(define (allocated-register? x)
  (and (register? x) (fx>= x 0)))

(define (get-target-register node cont reg1 reg2)
  (receive (reg call) (continuation-wants cont)
    (let ((call (and call (call-hoisted-cont call))))
      (cond ((and call (neq? (call-hoisted-cont node) call))
         (get-stack-register node))
        ((not (register? reg))
         (cond ((and (allocated-register? reg1)
             (dying? (reg-node reg1) node))
            (kill (reg-node reg1))
            reg1)
               ((and (allocated-register? reg2)
             (dying? (reg-node reg2) node))
            (kill (reg-node reg2))
            reg2)
           (else
            (get-register node))))
        (else
         (let ((var (reg-node reg)))
           (cond ((not var) reg)
             ((not (variable? var))
              (get-register node))
             ((and (eq? reg reg1) (dying? var node))
              (kill var)
              reg1)
             ((and (eq? reg reg2) (dying? var node))
              (kill var)
              reg2)
             ((leaf-node? cont)
              (kill var)
              reg)
             (else
              (iterate loop ((var var) (regs (list reg)))
                      (receive (reg cnode) (likely-next-reg-1 var cont)
             (let ((after-call?
                (and call cnode
                     (neq? (call-hoisted-cont cnode) call))))
              (cond ((or (null? reg) after-call?)
                 (cond ((and (not after-call?)
                         (get-reg-if-free node))
                    => (lambda (reg)
                         (move-registers reg regs)))
                       ((temp-loc var)
                    (set (register-loc var) nil)
                    (move-registers (car regs) (cdr regs)))
                       (else
                    (move-registers (get-stack-slot node)
                            regs))))
                ((or (eq? reg reg1) (eq? reg reg2))
                 (get-register node))
                ((reg-node reg)
                 => (lambda (var)
                      (cond ((or (not (variable? var))
                         (memq? reg regs))
                         (get-register node))
                        (else
                         (loop var (cons reg regs))))))
                (else
                 (move-registers reg regs))))))))))))))


(define (move-registers last regs)
  (iterate loop ((to last) (regs regs))
    (cond ((null? regs) to)
      (else
       (let* ((from (car regs))
          (from-var (reg-node from)))
         (set (register-loc from-var) nil)
         (set (temp-loc from-var) nil)
         (mark from-var to)
         (generate-move from to)
         (loop from (cdr regs)))))))



(lset get-register (lambda (node)
             (really-get-register node P *real-registers* t)))


(define (get-stack-register node)
  (or (really-get-register node *first-stack-register* *real-registers* nil)
      (really-get-register node P *first-stack-register* t)))

(define (get-stack-slot node)
  (or (really-get-register node *first-stack-register* *real-registers* nil)
      (really-get-temp node)))



(define (get-reg-if-free node)
  (really-get-register node P *first-stack-register* nil))


(define (really-get-register node start stop kick?)
  (iterate loop ((i start))
    (cond ((fx>= i stop)
           (if kick? (select-and-kick-register node) nil))
          ((not (reg-node i))
       (or (fx< i *first-stack-register*)
           (modify (lambda-max-temps *lambda*)
               (lambda (max-temp)
             (max 1 max-temp))))
           i)
          (else
           (loop (fx+ i 1))))))

(define (into-register node value access)
  (cond ((register-loc value))
        (else
         (let ((reg (get-register node)))
           (generate-move access reg)
           (cond ((register-loc value)
                  => (lambda (reg)
                       (set (reg-node reg) nil))))
           (mark value reg)
           reg))))


;;; SELECT-AND-KICK-REGISTER The first register which is not locked or used soo
;;; is selected.  If none satisfy then the first register  is selected.

(define (select-and-kick-register node)
         (iterate loop ((i A1) (default P)) ;kick P?
           (cond ((fx>= i *real-registers*)
                  (kick-register node default)
                  default)
                 ((locked? i)
                  (loop (fx+ i 1) default))
                 ((not (used-soon? node (reg-node i)))
                  (kick-register node i)
                  i)
                 (else (loop (fx+ i 1) i)))))


;;; USED-SOON? Is this variable used at this node or at one of its
;;; continuations?

(define (used-soon? node value)
  (let ((var-used? (lambda (arg)
                      (and (leaf-node? arg)
                           (eq? (leaf-value arg) value)))))
     (or (any? var-used? (call-args node))
         (any? (lambda (cont)
                 (any? var-used? (call-args (lambda-body cont))))
               (continuations node)))))

(define-integrable (free-register node reg)
  (if (reg-node reg) (kick-register node reg)))

(define (maybe-free reg cont)
  (cond ((reg-node reg)
         => (lambda (var)
              (cond ((and (variable? var)
                          (lambda-node? cont)
                          (let ((spec (likely-next-reg var cont)))
                            (cond ((and (fixnum? spec)
                                        (not (reg-node spec)))
                                   (generate-move reg spec)
                                   (set (reg-node reg) nil)
                                   (set (register-loc var) nil)
                                   (mark var spec)
                                   t)
                                  (else nil)))))
                     (else nil))))
         (else t)))



(define (kick-register node reg)
  (let ((value (reg-node reg)))
    (cond ((locked? reg)
           (error "attempt to kick out of locked register"))
          ((or (temp-loc value)
               (not (variable? value)))
           (set (register-loc value) nil)
           (set (reg-node reg) nil))
          ((get-reg-if-free node)
       => (lambda (temp)
        (set (register-loc value) temp)
        (set (reg-node reg) nil)
        (set (reg-node temp) value)
        (generate-move reg temp)))
      (else
           (let ((temp (get-stack-slot node)))
             (set (register-loc value) nil)
             (set (reg-node reg) nil)
             (mark value temp)
             (generate-move reg temp))))))



(define (really-get-temp node)
  (cond ((really-get-register  node *real-registers* *virtual-registers* nil)
         => (lambda (temp)
          (modify (lambda-max-temps *lambda*)
              (lambda (max-temp)
            (max temp max-temp)))
              temp))
        (else
         (bug "all temps used"))))


(define-integrable (cont node)
  (car (call-args node)))

(define (continuations node)
  (iterate loop ((i (call-exits node)) (args '()))
    (cond ((fx= i 0) args)
          (else
           (let ((arg ((call-arg i) node)))
             (loop (fx- i 1)
                   (cond ((lambda-node? arg) (cons arg args))
                         ((variable-known (leaf-value arg))
                          => (lambda (label) (cons label args)))
                         (else args))))))))

(define-integrable (then-cont node)
  (car (call-args node)))

(define-integrable (else-cont node)
  (cadr (call-args node)))

(define-integrable (kill-if-dying var node)
  (if (dying? var node) (kill var)))


(define (kill-if-dead node where)
  (cond ((lambda-node? node)
         (walk (lambda (var)
                 (if (not (or (memq? var (lambda-live where))
                              (fx= (variable-number var) 0)))
                     (kill var)))
               (lambda-live node)))
        ((or (not (variable? (leaf-value node)))
             (not (memq? (leaf-value node) (lambda-live where))))
         (kill (leaf-value node)))))

(define (kill value)
    (cond ((register-loc value)
           => (lambda (reg)
                (cond ((locked? reg)
                       (if (neq? (cdr (reg-node reg)) value)
                           (bug "horrible inconsistancy reg ~S value ~S"
                                 reg
                                 value))
                       (set (cdr (reg-node reg)) nil))
                      (else
                       (if (neq? (reg-node reg) value)
                           (bug "horrible inconsistancy reg ~S value ~S"
                                 reg
                                 value))
                       (set (reg-node reg) nil)))
                 (set (register-loc value) nil))))
    (cond ((temp-loc value)
           => (lambda (reg)
                (cond ((locked? reg)
                       (if (neq? (cdr (temp-node reg)) value)
                           (bug "horrible inconsistancy reg ~S value ~S"
                                 reg
                                 value))
                       (set (cdr (temp-node reg)) nil))
                      (else
                       (if (neq? (temp-node reg) value)
                           (bug "horrible inconsistancy reg ~S value ~S"
                                 reg
                                 value))
                       (set (temp-node reg) nil)))
                 (set (temp-loc value) nil)))))

(define (live? value node)
  (let ((value (cond ((and (pair? value) (variable? (cdr value)))
                      (cdr value))
                     ((variable? value) value)
                     (else nil))))
     (cond ((not value) nil)
       ((eq? value (lambda-self-var *lambda*)) t)
           (else
            (any? (lambda (cont)
                     (memq? value (lambda-live cont)))
                  (continuations node))))))

(define-integrable (dying? value node)
  (not (live? value node)))

(define (dead? value node)
  (let ((parent (node-parent node)))
    (not (and (variable? value)
              (or (memq? value (lambda-variables parent))
                  (memq? value (lambda-live parent)))))))

;;; pools for vector of registers (see ALLOCATE-CONDITIONAL-PRIMOP in reg.t)

(define register-vector-pool
        (make-pool 'reg-vec-pool
                   (lambda () (make-vector *virtual-registers*))
                   15
                   vector?))

(define-integrable (copy-registers)
  (vector-replace (obtain-from-pool register-vector-pool)
                  *registers*
                  *virtual-registers*))

(define-integrable (return-registers)
  (return-to-pool register-vector-pool *registers*))

(define (restore-slots)
    (restore-registers)
    (restore-temps))

(define (restore-registers)
  (do ((i 0 (fx+ i 1)))
      ((fx>= i *real-registers* ))
    (cond ((reg-node i)
           (set (register-loc (reg-node i)) i)))))

(define (restore-temps)
  (do ((i *real-registers* (fx+ i 1)))
      ((fx>= i *virtual-registers*))
    (cond ((temp-node i)
           (set (temp-loc (temp-node i)) i)))))



(define (clear-slots)
  (vector-fill *registers* nil)
  (recycle *locations*)
  (set *locations* (make-table 'locations)))

(define *lock-mark* (object nil ((identification self) 'lock)))


(define-integrable (lock reg)
  (and (fx>= reg 0)
       (fx< reg *virtual-registers*)
       (modify (reg-node reg) (lambda (node) (cons *lock-mark* node)))))

(define-integrable (unlock reg)
  (and (fx>= reg 0)
       (fx< reg *virtual-registers*)
       (modify (reg-node reg) cdr)))

(define-integrable (locked? reg)
  (let ((n (reg-node reg)))
    (and (pair? n) (eq? (car n) *lock-mark*))))

(define (protect-access access)
  (cond ((fixnum? access)
     (lock access))
        ((register? (car access))
     (lock (car access)))))

(define (release-access access)
  (cond ((fixnum? access)
     (unlock access))
        ((register? (car access))
     (unlock (car access)))))

(define (mark value reg)
  (cond ((register? reg)
     (set (reg-node reg) value)
     (set (register-loc value) reg))
    (else
     (set (temp-node reg) value)
     (set (temp-loc value) reg))))


;;; Locations
;;;==========================================================================
;;;   Keeps track of where values are.
;;; A table of a-lists of form ((<type-of-location> . <index>)...) indexed by
;;; leaf values, i.e. variables, primops, or literals.

(lset *locations* (make-table 'locations))

(define-integrable (leaf-locations value)
   (table-entry *locations* value))

(define-integrable register-loc
  (object (lambda (value)
            (get-location value 'reg))
    ((identification self) 'register-loc)
    ((setter self)
     (lambda (value reg)
       (if (null? reg)
           (clear-location value 'reg)
           (set-location value 'reg reg))))))

(define-integrable temp-loc
  (object (lambda (value)
            (get-location value 'temp))
    ((identification self) 'temp-loc)
    ((setter self)
     (lambda (value temp)
       (if (null? temp)
           (clear-location value 'temp)
           (set-location value 'temp temp))))))

(define-integrable (get-location value type)
  (cdr (assq type (leaf-locations value))))

(define (set-location value type number)
  (let ((locs (leaf-locations value)))
    (cond ((assq type locs)
           => (lambda (pair)
                (set (cdr pair) number)))
          (else
           (set-table-entry *locations* value (cons (cons type number) locs))))))

(define (clear-location value type)
  (let ((locs (leaf-locations value)))
    (set-table-entry *locations* value
         (del! (lambda (x y) (eq? x (car y))) type locs))
    nil))